home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacMETH 3.2.1 / Sources / MacC2.6 / M2LM.MOD < prev    next >
Encoding:
Modula Implementation  |  1992-05-29  |  6.5 KB  |  229 lines  |  [TEXT/MEDT]
  1. IMPLEMENTATION MODULE M2LM; (* Hermann Seiler, 20.5.85 / 10.6.86 *)
  2.  
  3.   (*$R- to avoid range errors in the compiler ! *)
  4.  
  5.   FROM SYSTEM IMPORT WORD, VAL;
  6.   FROM FileSystem IMPORT File, Response, Close, WriteWord;
  7.   FROM FileUtil IMPORT ExtLookup;
  8.   FROM M2DM IMPORT ObjPtr, StrPtr, KeyPtr, ObjClass;
  9.   FROM M2SM IMPORT Mark, IdBuf, Diff, Enter;
  10.  
  11.  
  12.   CONST
  13.  
  14.      CodeLength     = 27000;
  15.      ConstLength    = 5600;
  16.      CodeStartAdr   = 4;  (* pointer to global data space at *)
  17.                           (* PC-relative address 0.          *)
  18.  
  19.  
  20.   VAR
  21.  
  22.      conx           : CARDINAL;
  23.      codeoverflow   : BOOLEAN;
  24.      constoverflow  : BOOLEAN;
  25.      codeB          : ARRAY [ 0 .. CodeLength DIV 2 - 1 ] OF CARDINAL;
  26.      constB         : ARRAY [ 0 .. ConstLength-1] OF CHAR;
  27.  
  28.  
  29.  
  30.   PROCEDURE err(n : CARDINAL);
  31.     (* local synonym for M2SM.Mark. *)
  32.   BEGIN
  33.     Mark(n);
  34.   END err;
  35.  
  36.   PROCEDURE PutWord(w : WORD);
  37.     (* put a 16-bit word into the code-buffer. *)
  38.   BEGIN
  39.     codeB[pc DIV 2] := VAL(CARDINAL,w);
  40.     IF pc < CodeLength - 100 THEN
  41.       pc := pc + 2
  42.     ELSIF NOT codeoverflow THEN
  43.       codeoverflow := TRUE;
  44.       err(226);
  45.     END;
  46.   END PutWord;
  47.  
  48.   PROCEDURE PutLong(l : LONGINT);
  49.     (* put a 32-bit longword into the code-buffer. *)
  50.     VAR converter : RECORD
  51.                       CASE :BOOLEAN OF
  52.                         TRUE :  D   : LONGINT
  53.                       | FALSE:  H,L : CARDINAL
  54.                       END
  55.                     END;
  56.   BEGIN converter.D := l;
  57.     PutWord(converter.H);
  58.     PutWord(converter.L);
  59.   END PutLong;
  60.  
  61.   PROCEDURE AllocString(s : CARDINAL; VAR adr, length : INTEGER);
  62.     (* allocate a string-constant. *)
  63.     VAR L : CARDINAL;
  64.   BEGIN
  65.     adr := (*(maxP + maxM) * 4 +*) conx;
  66.     L   := ORD(IdBuf[s]) - 1; INC(s); length := L;
  67.     IF conx + L + 2 < ConstLength - 10 THEN
  68.       WHILE L > 0 DO
  69.         constB[conx] := IdBuf[s];
  70.         INC(conx); INC(s); DEC(L);
  71.       END;
  72.       constB[conx] := 0C; INC(conx);
  73.       (* assert word-alignment for strings : *)
  74.       IF ODD(conx) THEN constB[conx] := 0C; INC(conx) END;
  75.     ELSIF NOT constoverflow THEN
  76.       constoverflow := TRUE;
  77.       err(225);
  78.     END;
  79.   END AllocString;
  80.  
  81.   PROCEDURE AllocChar(ch : CHAR; VAR adr : INTEGER);
  82.     (* allocate a character-constant. *)
  83.   BEGIN
  84.     adr := (*(maxP + maxM) * 4 +*) conx;
  85.     IF conx + 2 < ConstLength - 10 THEN
  86.       (* Note : word-alignment is guaranteed by AllocString ! *)
  87.       constB[conx] := ch; INC(conx);
  88.       constB[conx] := 0C; INC(conx);
  89.     ELSIF NOT constoverflow THEN
  90.       constoverflow := TRUE;
  91.       err(225);
  92.     END;
  93.   END AllocChar;
  94.  
  95.   PROCEDURE AllocBounds(min, max, size : INTEGER; VAR adr : INTEGER);
  96.     (* allocate the bounds of a subrange or index. *)
  97.     VAR L : CARDINAL;
  98.   BEGIN
  99.     adr := 0 (* signal NO bound-pair allocated! *)
  100.   END AllocBounds;
  101.  
  102.   PROCEDURE fixup(loc : CARDINAL);
  103.     (* enter 16-bit displacement at loc. *)
  104.     VAR x : CARDINAL;
  105.   BEGIN
  106.     x := pc - loc; (* forward distance in bytes *)
  107.     codeB[loc DIV 2] := x;
  108.   END fixup;
  109.  
  110.   PROCEDURE FixLink(L : CARDINAL);
  111.     VAR L1 : CARDINAL; i: INTEGER;
  112.   BEGIN i := 0;
  113.     WHILE (L > 0) & (L < CodeLength) & (i < 10000) DO
  114.       L1 := codeB[L DIV 2];
  115.       fixup(L);
  116.       L := L1; INC(i);
  117.     END;
  118.   END FixLink;
  119.  
  120.   PROCEDURE FixupWith(loc : CARDINAL; disp : INTEGER);
  121.     (* enter 16-bit value disp at loc. *)
  122.   BEGIN
  123.     codeB[loc DIV 2] := VAL(CARDINAL,disp);
  124.   END FixupWith;
  125.  
  126.   PROCEDURE FixLinkWith(L, val : CARDINAL);
  127.     VAR L1 : CARDINAL; i: INTEGER;
  128.   BEGIN i := 0;
  129.     WHILE (L > 0) & (L < CodeLength) & (i < 10000) DO
  130.       L1 := codeB[L DIV 2];
  131.       FixupWith(L, VAL(INTEGER,val) - VAL(INTEGER,L)); (* forward distance *)
  132.       L := L1; INC(i);
  133.     END;
  134.   END FixLinkWith;
  135.  
  136.   PROCEDURE MergedLinks(L0, L1 : CARDINAL) : CARDINAL;
  137.     (* merge chain of the 2 operands of AND and OR. *)
  138.     VAR L2, L3 : CARDINAL; i: INTEGER;
  139.   BEGIN i := 0;
  140.     IF L0 <> 0 THEN
  141.       L2 := L0;
  142.       LOOP
  143.         L3 := codeB[L2 DIV 2];
  144.         IF (L3 = 0) OR (i >= 10000) THEN EXIT END;
  145.         L2 := L3; INC(i);
  146.       END;
  147.       codeB[L2 DIV 2] := L1;
  148.       RETURN L0;
  149.     ELSE
  150.       RETURN L1
  151.     END;
  152.   END MergedLinks;
  153.  
  154.   PROCEDURE InitM2LM;
  155.   BEGIN
  156.     pc := CodeStartAdr;
  157.     codeB[0] := 4E71H; codeB[1] := 4E71H; (* NOP's for the Decoder *)
  158.     conx := 0; maxP := 0; maxM := 0;
  159.     codeoverflow := FALSE; constoverflow := FALSE;
  160.   END InitM2LM;
  161.  
  162.   PROCEDURE OutCodeFile(VAR name : ARRAY OF CHAR; stamp : KeyPtr;
  163.                         datasize : INTEGER; pno, progid : CARDINAL;
  164.                         ModList : ObjPtr);
  165.     CONST HDR = 1; IMP = 2; COD = 3; DAT  = 4;
  166.     VAR   out: File; obj: ObjPtr; i, systemx: CARDINAL; ok: BOOLEAN;
  167.  
  168.     PROCEDURE W(w: WORD); BEGIN WriteWord(out, w) END W;
  169.  
  170.     PROCEDURE WriteNameAndKey(id: CARDINAL; stamp: KeyPtr);
  171.       VAR i, j, l, w: CARDINAL; ch: CHAR;
  172.     BEGIN
  173.       l := ORD(IdBuf[id]); j := id;
  174.       FOR i := 1 TO 8 DO
  175.         IF l > 1 THEN INC(j); DEC(l); ch := IdBuf[j] ELSE ch := 0C END;
  176.         w := VAL(CARDINAL,ORD(ch)) * 256;
  177.         IF l > 1 THEN INC(j); DEC(l); ch := IdBuf[j] ELSE ch := 0C END;
  178.         W(w + VAL(CARDINAL,ORD(ch)));
  179.       END;
  180.       IF Diff(id, systemx) = 0 THEN
  181.         W(0); W(0); W(0);
  182.       ELSE
  183.         W(stamp^.k0); W(stamp^.k1); W(stamp^.k2);
  184.       END;
  185.     END WriteNameAndKey;
  186.  
  187.     PROCEDURE WriteEntries(mod: ObjPtr);
  188.       VAR obj: ObjPtr;
  189.     BEGIN obj := mod^.firstObj;
  190.       WHILE obj # NIL DO
  191.         IF (obj^.class = Proc) & obj^.pd^.exp THEN W(0); W(obj^.pd^.adr)
  192.         ELSIF (obj^.class = Module) THEN WriteEntries(obj)
  193.         END;
  194.         obj := obj^.next
  195.       END
  196.     END WriteEntries;
  197.  
  198.   BEGIN
  199.     ExtLookup(out, name, TRUE, ok);
  200.     IF NOT ok THEN
  201.       err(222); (* output file not opened *)
  202.       RETURN;
  203.     END;
  204.     systemx := Enter('System');
  205.     (* HeaderBlock *)
  206.     W(HDR); W(34); W(0); WriteNameAndKey(progid, stamp); W(pc);
  207.     W(datasize); W(conx); W(maxP); W(maxM);
  208.     (* ImportBlock *)
  209.     W(IMP); W((maxM-1) * 22); obj := ModList^.next^.next;
  210.     WHILE obj # NIL DO WriteNameAndKey(obj^.name, obj^.key); obj := obj^.next END;
  211.     WriteNameAndKey(systemx, stamp);
  212.     (* CodeBlock *)
  213.     W(COD); W(pc); FOR i := 0 TO pc DIV 2 - 1 DO W(codeB[i]) END;
  214.     (* DataBlock *)
  215.     W(DAT); W((maxP+maxM)*4 + conx); W(0); W(4); WriteEntries(ModList^.next);
  216.     FOR i := 1 TO maxM DO W(0); W(0) END;
  217.     i := 0;
  218.     WHILE i < conx DO
  219.       W(VAL(CARDINAL,ORD(constB[i]))*256 + VAL(CARDINAL,ORD(constB[i+1])));
  220.       i := i + 2;
  221.     END;
  222.     Close(out);
  223.     IF out.res # done THEN
  224.       err(223); (* output incomplete *)
  225.     END;
  226.   END OutCodeFile;
  227.  
  228. END M2LM. (* Copyright Departement Informatik, ETH Zuerich, Switzerland, 1992 *)
  229.